home *** CD-ROM | disk | FTP | other *** search
/ El Mac 8 / El Mac 8.iso / Shareware / Applications / 4th Artificial Life / Extended.4th < prev    next >
Encoding:
Text File  |  1996-03-11  |  3.4 KB  |  83 lines  |  [TEXT/MSWD]
  1. \ *************** Some Brodie extensions ****************
  2.  
  3. 0 28 +md ! decimal page  \ keep screen clear, echo off
  4. : SPACES ( n -- )
  5.     ?dup IF 0 DO space LOOP THEN ;  \ emit n spaces
  6. : D- dnegate d+ ;  \ double length number subtraction
  7. : .(  41 word here count type ;  \ interactive printing utility
  8. : <> ( n1 n2 -- flag )  = 0= ;   \ true if n1 and n2 are not the same
  9. : 2- ( n -- n-2 ) ,$ 5556 ; MACRO  \ subq #2,(ps)
  10. : R@ ( -- n ) ( rstack: n -- n )   \ same as r
  11.     ,$ 3d17 ; MACRO                \ move  (a7),-(a6)
  12. : I ( -- n ) ( rstack: n -- n ) ( same as r and r@ )
  13.     ,$ 3d17 ; MACRO                \ move  (a7),-(a6)
  14. : J ( -- n ) ( rstack: n x m -- n x m )
  15.     ,$ 3d2f ,$ 0004 ; MACRO        \ move 4(a7),-(a6)
  16. : ? ( addr -- ) @ . ;  ( print variable )
  17. : ERASE ( addr n -- ) 0 fill ;  \ Fill addr with n zeros.
  18. : KEY? ( -- flag ) ?terminal ;
  19. : MOVE ( addr1 addr2 count -- ) cmove ;
  20. : CMOVE> ( addr1 addr2 count -- ) cmove ;
  21. : STRING ( c -- )  \ compile a string 
  22.     word here c@ 1+ ,$ 5256 ,$ 256 ,$ fffe allot ; \ keep HERE even
  23. \ These three words are redefined:
  24. : (word) word ;  
  25. : WORD ( c -- addr ) (word) here ;
  26. : (number)  number ;  
  27. : NUMBER ( addr -- d ) (number) IF  s>d  ELSE 0 0 THEN ;
  28. : COMPILE ( -- ) \ compile the next word from within a colon def.
  29.     token latest search IF        \ ( -- n ) addr of token
  30.       ,$ 24FC  ,$ 24FC ,$ 4EAB  ,  \ move.l #[move.l jsr n(a3)],(a2)+
  31.     ELSE  here count type space ." not found." abort
  32.     THEN ; IMMEDIATE
  33.  
  34. \ ******************** Extra extensions *************************
  35. : DABS dup 0< if -1 * then ;  
  36.  
  37. \ String storage
  38. : ?DEFINING ( -- flag ) cstate c@ ;     \ true if defining
  39. : ASCII ( -- c ) 32 word here 1+ c@     \ c = ascii of next character
  40.     ?defining IF literal THEN ; IMMEDIATE
  41. : EVEN ( n -- n' ) dup 2 mod + ;        \ round up to even number
  42. : ," ( -- )   ascii " word              \ get a quoted string
  43.     here c@ 1+ even allot ; IMMEDIATE
  44.  
  45. \ Font setting
  46. : !FONT ( n -- ) >r ,$ A887 ( _TextFont ) ; macro  \ set font
  47. : !FSIZE ( n -- ) >r ,$ A88A ( _TextSize ) ; macro  \ set size
  48. : !FACE ( face -- ) >r ,$ A888 ( _TextFace ) ; macro \ set style
  49. : !FMODE ( mode -- ) >r ,$ A889 ( _TextMode ) ; macro \ set mode
  50. : SYSFONT ( -- ) 0 !font  12 !fsize ;  \ set System font
  51. : MONACO9 ( -- ) 4 !font  09 !fsize  0 !fmode ;  \ set Normal font
  52.  
  53. \ Window
  54. : RCLIP ( rect -- ) a>r ,$ A87B ( _ClipRect ) ;
  55. : WINDOW ( -- d ) 0 +md 2@ ; \ d = window pointer
  56. : WSIZE ( h v -- )  \ change the window size            call: x y WSIZE
  57.     2dup  8 +md 2!  \ set the scroll rect 
  58.     window 2>r  2>r  256 >r  ,$ A91D ( _SizeWindow )
  59.     4 +md rclip ;   \ set drawing rect to whole window
  60. : WTITLE ( string.addr -- ) \ set the window title
  61.     window 2>r a>r ,$ A91A ( _SetWTitle ) ;
  62.  
  63. \ Colors (back and foreground)
  64.  33 constant BLACK     30 constant WHITE
  65. 205 constant RED      341 constant GREEN
  66. 409 constant BLUE     273 constant CYAN
  67. 137 constant MAGENTA   69 constant YELLOW
  68. : FCOLOR ( color.code -- ) 0 2>r ,$ A862 ;  ( _ForeColor )
  69. : BCOLOR ( back.color -- ) 0 2>r ,$ A863 ;  ( _BackColor )
  70.  
  71. \ Random numbers
  72. : SEED ( -- daddr ) ,$ 2d15 126 0 dnegate d+ ;
  73. : TIME ( -- d ) 524 0 dl@ ;
  74. : RANDOMIZE time seed dl! ;
  75. : RANDOM ( n -- n' )
  76.     0 >r ,$ A861  r> ( _Random )
  77.     swap 32768 */ abs ;  ( scale to size from stack )
  78.  
  79. \ ******************************************************************
  80. : READY -1 28 +md !                 \ Use READY to set echo on again!
  81.     PAGE ." Extensions loaded..." CR ;
  82.  
  83.